Cream of the Crop 26/Cream of the Crop 26.iso/program/fpkpas92.zip/SRCRTL.ZIP/RTL/STRINGS.PP

Text File | 1997-07-01 | 15.1 KB | 575 lines

{****************************************************************************

                        FPKPascal Runtime-Library
                  Copyright (c) 1993,94 by Florian Klämpfl

 ****************************************************************************}
{
  History:
  1.5.1994: Version 0.9
            Unit ist komplett implementiert (noch nicht getestet)
  20.3.1995: Version 0.91
            strmove korriert, für system.move müssen Pointer
            dereferenziert werden
  24.12.1995: Version 0.92
            strcomp war fehlerhaft; korrigiert
            dito strlcomp
}

unit strings;

  { Behandlung nullterminierter Strings }
  { für alle Betriebssysteme            }

  interface

    {$E-}

    { stellt die Länge des Strings fest }
    function strlen(p : pchar) : longint;

    { konvertiert einen Pascalstring in einen nullterminierten String }
    function strpcopy(d : pchar;const s : string) : pchar;

    { wandelt einen nullterminierten String in einen Pascalstring um }
    function strpas(p : pchar) : string;

    { kopiert source nach dest und liefert dest zurück }
    function strcopy(dest,source : pchar) : pchar;

    { kopiert source nach dest und liefert dest zurück, wobei max.  }
    { maxlen Zeichen kopiert werden                    }
    function strlcopy(dest,source : pchar;maxlen : longint) : pchar;

    { kopiert source nach dest und liefert einen Zeiger auf das    }
    { abschließende #0-Zeichen                       }
    function strecopy(dest,source : pchar) : pchar;

    { liefert einen Zeiger auf das abschließende #0-Zeichen von p  }
    function strend(p : pchar) : pchar;

    { hängt source an dest an und gibt dest zurück                 }
    function strcat(dest,source : pchar) : pchar;

    { vergleicht str1 und str2, liefert einen Wert <0 wenn         }
    { str1<str2; 0 wenn str1=str2 und einen Wert >0 wenn str1>str2 }
    function strcomp(str1,str2 : pchar) : longint;

    { wie strcomp, es werden jedoch maximal l Zeichen verglichen   }
    function strlcomp(str1,str2 : pchar;l : longint) : longint;

    { wie strcomp jedoch ohne Beachtung der Groß- und Klein-       }
    { schreibung                               }
    function stricomp(str1,str2 : pchar) : longint;

    { kopiert l Zeichen von source nach dest              }
    { und gibt dest zurück                      }
    function strmove(dest,source : pchar;l : longint) : pchar;

    { hängt source an dest an, wobei dest maximal l Zeichen       }
    { lang wird                              }
    function strlcat(dest,source : pchar;l : longint) : pchar;

    { gibt einen Zeiger auf das erste Auftreten von c zurück,      }
    { ansonsten nil                          }
    function strscan(p : pchar;c : char) : pchar;

    { gibt einen Zeiger auf das letzte Auftreten von c zurück,      }
    { ansonsten nil                          }
    function strrscan(p : pchar;c : char) : pchar;

    { wandelt p in Kleinbuchstaben um und gibt p zurück          }
    function strlower(p : pchar) : pchar;

    { wandelt p in Großbuchstaben um und gibt p zurück          }
    function strupper(p : pchar) : pchar;

    { wie stricomp, jedoch maximal l Zeichen              }
    function strlicomp(str1,str2 : pchar;l : longint) : longint;

    { liefert einen Zeiger auf das erste Auftreten von str2 in    }
    { str2 ansonsten wird nil zurück gegeben                  }
    function strpos(str1,str2 : pchar) : pchar;

    { legt eine Kopie von p auf dem Heap an und gibt einen Zeiger  }
    { darauf zurück                           }
    function strnew(p : pchar) : pchar;

    { löscht einen Zeiger vom Heap                   }
    procedure strdispose(p : pchar);

  implementation

    function strcopy(dest,source : pchar) : pchar;

      begin
         asm
            cld
            movl 12(%ebp),%edi
            movl $0xffffffff,%ecx
            xorb %al,%al
            repne
            scasb
            not %ecx
            movl 8(%ebp),%edi
            movl 12(%ebp),%esi
            movl %ecx,%eax
            shrl $2,%ecx
            rep
            movsl
            movl %eax,%ecx
            andl $3,%ecx
            rep
            movsb
            movl 8(%ebp),%eax
            leave
            ret $8
         end;
      end;

    function strecopy(dest,source : pchar) : pchar;

      begin
         asm
            cld
            movl 12(%ebp),%edi
            movl $0xffffffff,%ecx
            xorb %al,%al
            repne
            scasb
            not %ecx
            movl 8(%ebp),%edi
            movl 12(%ebp),%esi
            movl %ecx,%eax
            shrl $2,%ecx
            rep
            movsl
            movl %eax,%ecx
            andl $3,%ecx
            rep
            movsb
            movl 8(%ebp),%eax
            decl %edi
            movl %edi,%eax
            leave
            ret $8
         end ['EAX','ESI','EDI'];
      end;

    function strlcopy(dest,source : pchar;maxlen : longint) : pchar;

      begin
         asm
            movl 8(%ebp),%edi
            movl 12(%ebp),%esi
            movl 16(%ebp),%ecx
            cld
         LSTRLCOPY1:
            lodsb
            stosb
            decl %ecx        // max. Anzahl erniedrigen
            jz LSTRLCOPY2    // 0 erreicht, dann Ende
            orb %al,%al
            jnz LSTRLCOPY1
            movl 8(%ebp),%eax
            leave
            ret $12
        LSTRLCOPY2:
            xorb %al,%al    // falls abgeschnitten wurde, noch
            stosb        // ein #0 speichern
            movl 8(%ebp),%eax
            leave
            ret $12
         end ['EAX','ECX','ESI','EDI'];
      end;

    function strlen(p : pchar) : longint;

      begin
         asm
            cld
            movl 8(%ebp),%edi
            movl $0xffffffff,%ecx
            xorb %al,%al
            repne
            scasb
            movl $0xfffffffe,%eax
            subl %ecx,%eax
            leave
            ret $4
         end ['EDI','ECX','EAX'];
      end;

    function strend(p : pchar) : pchar;

      begin
         asm
            cld
            movl 8(%ebp),%edi
            movl $0xffffffff,%ecx
            xorb %al,%al
            repne
            scasb
            movl %edi,%eax
            decl %eax
            leave
            ret $4
         end ['EDI','ECX','EAX'];
      end;

    function strpcopy(d : pchar;const s : string) : pchar;

      begin
     asm
        pushl %esi        // ESI wird nicht automatisch gerettet
        cld
        movl 8(%ebp),%edi    // Zieladresse laden
        movl 12(%ebp),%esi   // Quelladresse laden
        movl %edi,%ebx      // Rückgabewert speichern
        lodsb        // Längenbyte laden und nach ECX
        movzbl %al,%ecx
        rep
        movsb
        xorb %al,%al    // Nullbyte speichern
        stosb
        movl %ebx,%eax    // Rückgabeadresse nach EAX
        popl %esi
        leave        // ... und fertig
        ret $8
     end ['EDI','ESI','EBX','EAX','ECX'];
      end;

    function strpas(p : pchar) : string;

      begin
         asm
            cld
            movl 12(%ebp),%edi
            movl %edi,%esi               // Quelle
            movl $0xffffffff,%ecx        // nach Ende suchen
            xorb %al,%al
            repne
            scasb
            notl %ecx
            decl %ecx
            movl 8(%ebp),%edi          //  Ziel neu laden
            movb %cl,%al
            stosb
            rep
            movsb
         end ['ECX','EAX','ESI','EDI'];
      end;

    function strcat(dest,source : pchar) : pchar;

      begin
         strcat:=strcopy(strend(dest),source);
      end;

    function strlcat(dest,source : pchar;l : longint) : pchar;

      var
         destend : pchar;

      begin
         destend:=strend(dest);
         l:=l-(destend-dest);
         strlcat:=strlcopy(destend,source,l);
      end;

    function strcomp(str1,str2 : pchar) : longint;

      begin
         asm
            // Nullbyte im ersten String suchen
            movl 12(%ebp),%edi
            movl $0xffffffff,%ecx
            cld
            xorl %eax,%eax
            repne
            scasb
            not %ecx
            movl 12(%ebp),%edi
            movl 8(%ebp),%esi
            repe
            cmpsb
            movb -1(%esi),%al
            movzbl -1(%edi),%ecx
            subl %ecx,%eax
            leave
            ret $8
         end ['EAX','ECX','ESI','EDI'];
      end;

    function strlcomp(str1,str2 : pchar;l : longint) : longint;

      begin
         asm
            // Nullbyte im ersten String suchen
            movl 12(%ebp),%edi
            movl $0xffffffff,%ecx
            cld
            xorl %eax,%eax
            repne
            scasb
            not %ecx
            cmpl 16(%ebp),%ecx
            jl LSTRLCOMP1
            movl 16(%ebp),%ecx
        LSTRLCOMP1:
            movl 12(%ebp),%edi
            movl 8(%ebp),%esi
            repe
            cmpsb
            movb -1(%esi),%al
            movzbl -1(%edi),%ecx
            subl %ecx,%eax
            leave
            ret $12
         end ['EAX','ECX','ESI','EDI'];
      end;

    function stricomp(str1,str2 : pchar) : longint;

      begin
         asm
            // Nullbyte im ersten String suchen
            movl 12(%ebp),%edi
            movl $0xffffffff,%ecx
            cld
            xorl %eax,%eax
            repne
            scasb
            not %ecx
            movl 12(%ebp),%edi
            movl 8(%ebp),%esi
       LSTRICOMP2:
            repe
            cmpsb
            jz LSTRICOMP3    // falls Ende erreicht dann herausspringen
            movb (%esi),%al
            movzbl (%edi),%ebx
            cmpb $97,%al
            jb LSTRICOMP1
            cmpb $122,%al
            ja LSTRICOMP1
            subb $0x20,%al
        LSTRICOMP1:
            cmpb $97,%bl
            jb LSTRICOMP4
            cmpb $122,%bl
            ja LSTRICOMP4
            subb $0x20,%bl
       LSTRICOMP4:
            subl %ebx,%eax
            jz LSTRICOMP2    // falls immer noch gleich nochmals
                                 // vergleichen
       LSTRICOMP3:
            leave
            ret $8
         end ['EAX','ECX','ESI','EDI'];
      end;

    function strlicomp(str1,str2 : pchar;l : longint) : longint;

      begin
         asm
            // Nullbyte im ersten String suchen
            movl 12(%ebp),%edi
            movl $0xffffffff,%ecx
            cld
            xorl %eax,%eax
            repne
            scasb
            not %ecx
            cmpl 16(%ebp),%ecx
            jl LSTRLICOMP5
            movl 16(%ebp),%ecx
       LSTRLICOMP5:
            movl 12(%ebp),%edi
            movl 8(%ebp),%esi
       LSTRLICOMP2:
            repe
            cmpsb
            jz LSTRLICOMP3    // falls Ende erreicht dann herausspringen
            movb (%esi),%al
            movzbl (%edi),%ebx
            cmpb $97,%al
            jb LSTRLICOMP1
            cmpb $122,%al
            ja LSTRLICOMP1
            subb $0x20,%al
        LSTRLICOMP1:
            cmpb $97,%bl
            jb LSTRLICOMP4
            cmpb $122,%bl
            ja LSTRLICOMP4
            subb $0x20,%bl
       LSTRLICOMP4:
            subl %ebx,%eax
            jz LSTRLICOMP2    // falls immer noch gleich nochmals
                                 // vergleichen
       LSTRLICOMP3:
            leave
            ret $12
         end ['EAX','ECX','ESI','EDI'];
      end;

    function strmove(dest,source : pchar;l : longint) : pchar;

      begin
         move(source^,dest^,l);
         strmove:=dest;
      end;

    function strscan(p : pchar;c : char) : pchar;

      begin
         asm
            movl 8(%ebp),%edi
            movl $0xffffffff,%ecx
            cld
            xorb %al,%al
            repne
            scasb
            not %ecx
            movb 12(%ebp),%al
            movl 8(%ebp),%edi
            repne
            scasb
            movl $0,%eax    // EAX löschen, wenn bis Ende verglichen
                        // dann nil zurückgeben
            jnz LSTRSCAN
            movl %edi,%eax    // sonst den um 1 erniedrigten Wert von
                        // EDI nach EAX
            decl %eax
        LSTRSCAN:
            leave
            ret $6
         end;
      end;

    function strrscan(p : pchar;c : char) : pchar;

      begin
         asm
            movl 8(%ebp),%edi
            movl $0xffffffff,%ecx
            cld
            xorb %al,%al
            repne
            scasb
            not %ecx
            movb 12(%ebp),%al
            movl 8(%ebp),%edi
            addl %ecx,%edi
            decl %edi
            std
            repne
            scasb
            movl $0,%eax    // EAX löschen, wenn bis Ende verglichen
                        // dann nil zurückgeben
            jnz LSTRSCAN
            movl %edi,%eax    // sonst den um 1 erhöhten Wert von
                        // EDI nach EAX
            incl %eax
        LSTRRSCAN:
            leave
            ret $6
         end;
      end;

    function strupper(p : pchar) : pchar;

      begin
         asm
            movl 8(%ebp),%esi
            movl %esi,%edi
         LSTRUPPER1:
            lodsb
            cmpb $97,%al
            jb LSTRUPPER3
            cmpb $122,%al
            ja LSTRUPPER3
            subb $0x20,%al
         LSTRUPPER3:
            stosb
            orb %al,%al
            jnz LSTRUPPER1
            movl 8(%ebp),%eax
            leave
            ret $4
         end;
      end;

    function strlower(p : pchar) : pchar;

      begin
         asm
            movl 8(%ebp),%esi
            movl %esi,%edi
         LSTRLOWER1:
            lodsb
            cmpb $65,%al
            jb LSTRLOWER3
            cmpb $90,%al
            ja LSTRLOWER3
            addb $0x20,%al
         LSTRLOWER3:
            stosb
            orb %al,%al
            jnz LSTRLOWER1
            movl 8(%ebp),%eax
            leave
            ret $4
         end;
      end;

    function strpos(str1,str2 : pchar) : pchar;

      var
         p : pchar;
         lstr2 : longint;

      begin
         strpos:=nil;
         p:=strscan(str1,str2^);
         if p=nil then
           exit;
         lstr2:=strlen(str2);
         while p<>nil do
           begin
              if strlcomp(p,str2,lstr2)=0 then
                begin
                   strpos:=p;
                   exit;
                end;
              inc(longint(p));
              p:=strscan(p,str2^);
           end;
      end;

    procedure strdispose(p : pchar);

      begin
         if p<>nil then
           freemem(p,strlen(p)+1);
      end;

    function strnew(p : pchar) : pchar;

      var
         len : longint;

      begin
         strnew:=nil;
         if (p=nil) or (p^=#0) then
           exit;
         len:=strlen(p)+1;
         getmem(strnew,len);
         if strnew<>nil then
           strmove(strnew,p,len);
      end;

end.